Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/TCPOOExample/TCP Libraries/TCPOOConnections.unit

Text File | 1993-06-30 | 18.3 KB | 823 lines | [TEXT/PJMM]

unit TCPOOConnections;

{ TCPOOConnections © Peter Lewis, April 1993 }

interface

    uses
        TCPTypes, TCPStuff, MyTypes;

    const
        tooManyConnections = -23099;
        timeoutError = -23098;
        failedToOpenError = 23097;

{ Sequence: }
{ new(obj) }
{ oe:=obj.Create }
{ if oe=noErr then begin }
{   do stuff}
{ end; }
{ obj.Destroy }

    type
        ConnectionBaseObject = object
                timetodie: boolean; { Set this to have Destroy called at the end of HandleConnection }
                connection_index: integer; { private! }
                closedone, terminatedone: boolean;
                heartbeat_period: longInt; { set to <=0 to disable heartbeats }
                heartbeat_time: longInt; { set to time of next heartbeat, it is automatically incrememnted by the period }
{ To enable heartbeats, set heartbeat_time to TickCount, and heartbeat_period to the period in ticks }
                timeout_time: longInt; { set to time to timeout TickCount }
                function Create: OSErr;
                procedure Destroy;
                procedure HeartBeat;
                procedure Failed (oe: OSErr);
                procedure Timeout;
                procedure Terminate;
                procedure Close;
                function HandleConnection: boolean;
            end;
        GeneralSearchObject = object(ConnectionBaseObject)
                hip: ptr; { private! }
                function Create: OSErr;
                override;
                procedure Destroy;
                override;
            end;
        NameSearchObject = object(GeneralSearchObject)
                ip: longInt;
                function HandleConnection: boolean;
                override;
                function FindName (hostIP: longInt): OSErr;
                procedure FoundName (name: str255; error: OSErr);
            end;
        AddressSearchObject = object(GeneralSearchObject)
                function HandleConnection: boolean;
                override;
                function FindAddress (hostName: str255): OSErr;
                procedure FoundAddress (ip: longInt);
            end;
        UDPObject = object(ConnectionBaseObject)
                udpcp: UDPConnectionPtr;
                localport: integer;
                function CreatePort (buffer_size: longInt; port: integer): OSErr;
                procedure Close;
                override;
                procedure Terminate;
                override;
                procedure Destroy;
                override;
                function HandleConnection: boolean;
                override;
                procedure PacketAvailable (remoteIP: longInt; remoteport: integer; datap: ptr; datalen: integer);
                procedure PacketsAvailable (count: integer);
                function SendPacket (remoteIP: longInt; remoteport: integer; datap: ptr; datalen: integer; checksum: boolean): OSErr;
            end;
        statusType = (CS_Opening, CS_Established, CS_Closing);
        ConnectionObject = object(ConnectionBaseObject)
                tcpc: TCPConnectionPtr;
                status: statusType;
                procedure Destroy;
                override;
                function HandleConnection: boolean;
                override;
                function NewPassiveConnection (buffersize: longInt; localport: integer; remotehost: longInt; remoteport: integer): OSErr;
                function NewActiveConnection (buffersize: longInt; remotehost: longInt; remoteport: integer): OSErr;
                procedure Close;
                override;
                procedure Terminate;
                override;
                procedure Established;
                procedure Closing;
                procedure CharsAvailable (count: longInt);
            end;
        LineConnectionObject = object(ConnectionObject)
                crlf: CRLFTypes;
                buffer: str255;
                function Create: OSErr;
                override;
                procedure SendLine (s: str255);
                procedure LineAvailable (line: str255);
                procedure CharsAvailable (count: longInt);
                override;
            end;

    function InitConnections: OSErr;
    procedure FinishConnections;
    function HandleConnections (maxtime: integer): boolean;
    procedure ConnectionsAddrToString (ip: longInt; var addrStr: str255);
    function ConnectionsAddrToStr (ip: longInt): str255;
    function ConnectionsStrToAddr (s: str255; var addr: longInt): boolean;
{ You probably wont need these: }
    procedure TerminateConnections;
    procedure CloseConnections;
    function CanQuit: boolean;

implementation

    const
        TCPCMagic = 'TCPC';
        TCPCBadMagic = 'badc';

    const  { Tuning parameters }
        max_connections = 64;
        TO_FindAddress = 40 * 60;
        TO_FindName = 40 * 60;
        TO_ActiveOpen = 20 * 60;
        TO_Closing = longInt(2) * 60 * 60;
        TO_PassiveOpen = longInt(10) * 365 * 24 * 3600 * 60;  { Ten years should be safe enough right? :-) }

    type
        myHostInfo = record
                hi: hostInfo;
                done: signedByte;
            end;
        myHIP = ^myHostInfo;

    type
        connectionRecord = record
                obj: ConnectionBaseObject;
            end;

    var
        connections: array[1..max_connections] of connectionRecord;
        connectionItem: integer;
        dnrptr: ptr;

    function MyTCPState (con: TCPConnectionPtr): TCPStateType;
    begin
        if con = nil then
            MyTCPState := T_Closed
        else
            MyTCPState := TCPState(con);
    end;

{$S Init}
    function InitConnections: OSErr;
        var
            oe: OSErr;
            i: integer;
    begin
        icmp_sent_out := 0;
        icmp_got_back := 0;
        connectionItem := 1;
        for i := 1 to max_connections do
            connections[i].obj := nil;
        oe := TCPInit;
        if oe = noErr then begin
            oe := TCPOpenResolver(dnrptr);
            if oe <> noErr then
                TCPFinish;
        end;
        InitConnections := oe;
    end;
{$S}

{$S Term}
    procedure TerminateConnections;
        var
            i: integer;
    begin
        for i := 1 to max_connections do
            if connections[i].obj <> nil then begin
                if not connections[i].obj.terminatedone then
                    connections[i].obj.Terminate;
            end;
    end;
{$S}

{$S Term}
    procedure CloseConnections;
        var
            i: integer;
    begin
        for i := 1 to max_connections do
            if connections[i].obj <> nil then begin
                connections[i].obj.Close;
            end;
    end;
{$S}

{$S Term}
    function CanQuit: boolean;
        var
            i: integer;
    begin
        CanQuit := icmp_sent_out = icmp_got_back;
        for i := 1 to max_connections do
            if connections[i].obj <> nil then begin
                CanQuit := false;
                leave;
            end;
    end;

{$S Term}
    procedure FinishConnections;
        var
            dummy: boolean;
            er: eventRecord;
    begin
        while not CanQuit do begin
            TerminateConnections;
            if HandleConnections(3) then begin
                dummy := WaitNextEvent(everyEvent, er, 0, nil);
            end
            else
                dummy := WaitNextEvent(everyEvent, er, 5, nil);
        end;
        TCPCloseResolver(dnrptr);
        TCPFinish;
    end;
{$S}

    function ConnectionBaseObject.Create: OSErr;
        var
            i: integer;
            oe: OSErr;
    begin
        i := 1;
        while (i <= max_connections) & (connections[i].obj <> nil) do
            i := i + 1;
        if i <= max_connections then begin
            timetodie := false;
            connection_index := i;
            connections[i].obj := self;
            heartbeat_period := 0;
            heartbeat_time := 0;
            timeout_time := maxLongInt;
            closedone := false;
            terminatedone := false;
            oe := noErr;
        end
        else begin
            connection_index := -1;
            oe := tooManyConnections;
        end;
        Create := oe;
    end;

    procedure ConnectionBaseObject.Destroy;
    begin
        if connection_index > 0 then
            connections[connection_index].obj := nil;
        dispose(self);
    end;

    procedure ConnectionBaseObject.HeartBeat;
    begin
    end;

    procedure ConnectionBaseObject.Failed (oe: OSErr);
    begin
        timetodie := true;
    end;

    procedure ConnectionBaseObject.Timeout;
    begin
        Failed(timeoutError);
    end;

    procedure ConnectionBaseObject.Terminate;
    begin
        terminatedone := true;
    end;

    procedure ConnectionBaseObject.Close;
    begin
        closedone := true;
    end;

    function ConnectionBaseObject.HandleConnection: boolean;
        var
            now: longInt;
    begin
        HandleConnection := false;
        now := TickCount;
        if now > timeout_time then begin
            timeout_time := maxLongInt;
            Timeout;
            HandleConnection := true;
        end
        else if (heartbeat_period > 0) & (now >= heartbeat_time) then begin
            HeartBeat;
            heartbeat_time := heartbeat_time + heartbeat_period;
            HandleConnection := true;
        end;
    end;

    function GeneralSearchObject.Create: OSErr;
        var
            oe: OSErr;
    begin
        oe := inherited Create;
        hip := nil;
        if oe = noErr then begin
            hip := NewPtr(SizeOf(myHostInfo));
            oe := MemError;
        end;
        Create := oe;
    end;

    procedure GeneralSearchObject.Destroy;
    begin
        if hip <> nil then begin
            DisposePtr(hip);
            hip := nil;
        end;
        inherited Destroy;
    end;

    function AddressSearchObject.FindAddress (hostName: str255): OSErr;
        var
            oe: OSErr;
    begin
        oe := Create;
        if oe = noErr then begin
            myHIP(hip)^.done := 0;
            oe := TCPStrToAddr(dnrptr, hostName, myHIP(hip)^.hi, myHIP(hip)^.done);
            if oe = cacheFault then begin
                timeout_time := TickCount + TO_FindAddress;
                oe := noErr;
            end
            else begin
                myHIP(hip)^.done := -1;
                myHIP(hip)^.hi.rtnCode := oe;
            end;
        end;
        if oe <> noErr then
            Destroy;
        FindAddress := oe;
    end;

    procedure AddressSearchObject.FoundAddress (ip: longInt);
    begin
    end;

    function AddressSearchObject.HandleConnection: boolean;
    begin
        with myHIP(hip)^, hi do begin
            if rtnCode = noErr then begin
                FoundAddress(addrs[1]);
                timetodie := true;
                HandleConnection := true;
            end
            else if done <> 0 then begin
                Failed(rtnCode);
                timetodie := true;
                HandleConnection := true;
            end
            else
                HandleConnection := inherited HandleConnection;
        end; {with}
    end;

    function NameSearchObject.FindName (hostIP: longInt): OSErr;
        var
            oe: OSErr;
            hostname: str255;
    begin
        ip := hostIP;
        oe := Create;
        if oe = noErr then begin
            myHIP(hip)^.done := 0;
            oe := TCPAddrToName(dnrptr, hostIP, myHIP(hip)^.hi, myHIP(hip)^.done);
            if oe = cacheFault then begin
                timeout_time := TickCount + TO_FindName;
                oe := noErr;
            end
            else begin
                myHIP(hip)^.done := -1;
                myHIP(hip)^.hi.rtnCode := oe;
            end;
        end;
        if oe <> noErr then begin
            TCPAddrToStr(dnrptr, hostIP, hostname);
            FoundName(hostname, oe);
        end;
        if oe <> noErr then
            Destroy;
        FindName := oe;
    end;

    procedure NameSearchObject.FoundName (name: str255; error: OSErr);
    begin
    end;

    function NameSearchObject.HandleConnection: boolean;
    begin
        with myHIP(hip)^, hi do begin
            if done <> 0 then begin
                if rtnCode = noErr then begin
                    SanitizeHostName(rtnHostName);
                    FoundName(rtnHostName, noErr);
                    timetodie := true;
                    HandleConnection := true;
                end
                else begin
                    TCPAddrToStr(dnrptr, ip, rtnHostName);
                    FoundName(rtnHostName, rtnCode);
                    timetodie := true;
                    HandleConnection := true;
                end
            end
            else
                HandleConnection := inherited HandleConnection;
        end; {with}
    end;

    procedure ConnectionObject.Established;
    begin
    end;

    procedure ConnectionObject.Closing;
    begin
    end;

    procedure ConnectionObject.CharsAvailable (count: longInt);
    begin
    end;

    procedure ConnectionObject.Destroy;
        var
            tmp_tcpc: TCPConnectionPtr;
            oe: OSErr;
    begin
        if tcpc <> nil then begin
            oe := TCPAbort(tcpc);
            tmp_tcpc := tcpc;
            oe := TCPRelease(tmp_tcpc);
        end;
        inherited Destroy;
    end;

    function ConnectionObject.NewPassiveConnection (buffersize: longInt; localport: integer; remotehost: longInt; remoteport: integer): OSErr;
        var
            oe: OSErr;
            tmp_tcpc: TCPConnectionPtr;
    begin
        oe := Create;
        if oe = noErr then begin
            oe := TCPPassiveOpen(tmp_tcpc, buffersize, localPort, remotehost, remoteport, nil);
            tcpc := tmp_tcpc;
            status := CS_Opening;
            timeout_time := TickCount + TO_PassiveOpen;
        end;
        if oe <> noErr then begin
            tcpc := nil;
            Destroy;
        end;
        NewPassiveConnection := oe;
    end;

    function ConnectionObject.NewActiveConnection (buffersize: longInt; remotehost: longInt; remoteport: integer): OSErr;
        var
            oe: OSErr;
            tmp_tcpc: TCPConnectionPtr;
    begin
        oe := Create;
        if oe = noErr then begin
            oe := TCPActiveOpen(tmp_tcpc, buffersize, 0, remotehost, remoteport, nil);
            tcpc := tmp_tcpc;
            status := CS_Opening;
            timeout_time := TickCount + TO_ActiveOpen;
        end;
        if oe <> noErr then begin
            tcpc := nil;
            Destroy;
        end;
        NewActiveConnection := oe;
    end;

    procedure ConnectionObject.Close;
        var
            oe: OSErr;
    begin
        if not closedone and (tcpc <> nil) then begin
            oe := TCPClose(tcpc, nil);
            closedone := true;
        end;
    end;

    procedure ConnectionObject.Terminate;
        var
            oe: OSErr;
    begin
        if not terminatedone and (tcpc <> nil) then begin
            oe := TCPAbort(tcpc);
            terminatedone := true;
        end;
    end;


    function ConnectionObject.HandleConnection: boolean;
        var
            didit: boolean;
            count: longInt;
            state: TCPStateType;
    begin
        didit := false;
        state := MyTCPState(tcpc);
        case status of
            CS_Opening:  begin
                case state of
                    T_WaitingForOpen, T_Opening, T_Listening:
                        ;
                    T_Established:  begin
                        Established;
                        status := CS_Established;
                        timeout_time := maxLongInt;
                        didit := true;
                    end;
                    T_PleaseClose, T_Closing, T_Closed:  begin
                        didit := true;
                        Failed(failedToOpenError);
                        timetodie := true;
                    end;
                    otherwise
                        ;
                end; {case }
            end;
            CS_Established:  begin
                case state of
                    T_Established:  begin
                        count := TCPCharsAvailable(tcpc);
                        if count > 0 then begin
                            CharsAvailable(count);
                            didit := true;
                        end;
                    end;
                    T_PleaseClose, T_Closing:  begin
                        count := TCPCharsAvailable(tcpc);
                        if count > 0 then begin
                            CharsAvailable(count);
                            didit := true;
                        end
                        else begin
                            Closing;
                            status := CS_Closing;
                            timeout_time := TickCount + TO_Closing;
                            didit := true;
                        end;
                    end;
                    T_Closed:  begin
                        Closing;
                        status := CS_Closing;
                        timeout_time := TickCount + TO_Closing;
                        didit := true;
                    end;
                    otherwise
                        ;
                end;
            end;
            CS_Closing:  begin
                case state of
                    T_PleaseClose, T_Closing, T_Established:  begin
                        count := TCPCharsAvailable(tcpc);
                        if count > 0 then begin
                            CharsAvailable(count);
                            didit := true;
                        end;
                    end;
                    T_Closed:  begin
                        timetodie := true;
                        didit := true;
                    end;
                    otherwise
                        ;
                end;
            end;
            otherwise
                ;
        end;
        if not didit then
            didit := inherited HandleConnection;
        HandleConnection := didit;
    end;

    function LineConnectionObject.Create: OSErr;
    begin
        crlf := CL_CRLF;
        buffer := '';
        Create := inherited Create;
    end;

    procedure LineConnectionObject.SendLine (s: str255);
        var
            oe: OSErr;
    begin
        if crlf <> CL_LF then
            s := concat(s, cr);
        if crlf <> CL_CR then
            s := concat(s, lf);
        oe := TCPSendAsync(tcpc, @s[1], length(s), true, nil);
    end;

    procedure LineConnectionObject.LineAvailable (line: str255);
    begin
    end;

    procedure LineConnectionObject.CharsAvailable (count: longInt);
        var
            oe: OSErr;
            pos: longInt;
            gotlf: boolean;
            termchar: char;
            s: str255;
    begin
{$PUSH}
{$R-}
        if crlf = CL_CR then
            termchar := cr
        else
            termchar := lf;
        s := buffer;
        pos := length(s);
        oe := TCPReceiveUpTo(tcpc, ord(termchar), 0, @s[1], 255, pos, gotlf);
        s[0] := chr(pos);
        buffer := s;
        if gotlf or (length(buffer) = 255) then begin
            if (length(buffer) > 0) and (buffer[length(buffer)] = lf) then
                buffer[0] := chr(length(buffer) - 1);
            if (length(buffer) > 0) and (buffer[length(buffer)] = cr) then
                buffer[0] := chr(length(buffer) - 1);
            LineAvailable(buffer);
            buffer := '';
        end;
{$POP}
    end;

    function UDPObject.CreatePort (buffer_size: longInt; port: integer): OSErr;
        var
            oe: OSErr;
            tmp_udpcp: UDPConnectionPtr;
    begin
        oe := Create;
        if oe = noErr then begin
            oe := UDPCreate(tmp_udpcp, buffer_size, port);
            udpcp := tmp_udpcp;
            localport := port;
            timeout_time := maxLongInt;
        end;
        if oe <> noErr then begin
            udpcp := nil;
            Destroy;
        end;
        CreatePort := oe;
    end;

    procedure UDPObject.Terminate;
    begin
        Close;
    end;

    procedure UDPObject.Close;
        var
            tmp_udpcp: UDPConnectionPtr;
            oe: OSErr;
    begin
        if udpcp <> nil then begin
            tmp_udpcp := udpcp;
            oe := UDPRelease(tmp_udpcp);
            udpcp := nil;
        end;
        timetodie := true;
    end;

    procedure UDPObject.Destroy;
    begin
        if udpcp <> nil then begin
            Close;
        end;
        inherited Destroy;
    end;

    procedure UDPObject.PacketAvailable (remoteIP: longInt; remoteport: integer; datap: ptr; datalen: integer);
    begin
    end;

    procedure UDPObject.PacketsAvailable (count: integer);
        var
            oe: OSErr;
            remoteIP: longInt;
            remoteport: integer;
            datap: ptr;
            datalen: integer;
            u: UDPConnectionPtr;
    begin
        oe := UDPRead(udpcp, 1, remoteIP, remoteport, datap, datalen);
        if oe = noErr then begin
            u := udpcp;
            PacketAvailable(remoteIP, remoteport, datap, datalen);
{ self may be nil now }
            oe := UDPReturnBuffer(u, datap);
        end;
    end;

    function UDPObject.SendPacket (remoteIP: longInt; remoteport: integer; datap: ptr; datalen: integer; checksum: boolean): OSErr;
    begin
        SendPacket := UDPWrite(udpcp, remoteIP, remoteport, datap, datalen, checksum);
    end;

    function UDPObject.HandleConnection: boolean;
        var
            didit: boolean;
            count: longInt;
    begin
        didit := false;
        if udpcp <> nil then begin
            count := UDPDatagramsAvailable(udpcp);
            if count > 0 then begin
                PacketsAvailable(count);
                didit := true;
            end;
        end;
        if not didit then
            didit := inherited HandleConnection;
        HandleConnection := didit;
    end;

    function HandleConnections (maxtime: integer): boolean;
        var
            oci: integer;
            did, didthis: boolean;
            start: longInt;
    begin
        start := TickCount;
        oci := connectionItem;
        did := false;
        repeat
            if connections[connectionItem].obj <> nil then begin
                repeat
                    didthis := connections[connectionItem].obj.HandleConnection;
                    if (connections[connectionItem].obj <> nil) & (connections[connectionItem].obj.timetodie) then
                        connections[connectionItem].obj.Destroy;
                    if didthis then
                        did := true;
                until not didthis or (connections[connectionItem].obj = nil) or (TickCount >= start + maxtime);
            end;{if}
            if connectionItem = max_connections then
                connectionItem := 1
            else
                connectionItem := connectionItem + 1;
        until did or (oci = connectionItem);
        HandleConnections := did;
    end;

    function ConnectionsStrToAddr (s: str255; var addr: longInt): boolean;
        var
            good: boolean;
        procedure Get1;
            var
                b: integer;
        begin
            if (length(s) = 0) | not (s[1] in ['0'..'9']) then
                good := false
            else begin
                b := ord(s[1]) - 48;
                s := copy(s, 2, 255);
                if (s <> '') & (s[1] in ['0'..'9']) then begin
                    b := b * 10 + ord(s[1]) - 48;
                    s := copy(s, 2, 255);
                end;
                if (s <> '') & (s[1] in ['0'..'9']) then begin
                    b := b * 10 + ord(s[1]) - 48;
                    s := copy(s, 2, 255);
                end;
                if (s <> '') & (s[1] = '.') then begin
                    s := copy(s, 2, 255);
                end;
                if b > 255 then begin
                    good := false;
                    b := 0; { avoid overflow error? }
                end;
                addr := BOR(BSL(addr, 8), b);
            end;
        end;
    begin
        good := true;
        addr := 0;
        Get1;
        Get1;
        Get1;
        Get1;
        good := good & (s = '');
        if not good then
            addr := 0;
        ConnectionsStrToAddr := good;
    end;

    procedure ConnectionsAddrToString (ip: longInt; var addrStr: str255);
    begin
        TCPAddrToStr(dnrptr, ip, addrStr);
    end;

    function ConnectionsAddrToStr (ip: longInt): str255;
        var
            s: str255;
    begin
        TCPAddrToStr(dnrptr, ip, s);
        ConnectionsAddrToStr := s;
    end;

end.